home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / env / coreinfo.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  3.0 KB  |  90 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. (* coreinfo.sml *)
  3.  
  4. (* info extracted from Core structure *)
  5.  
  6. structure CoreInfo : COREINFO =
  7. struct
  8.  
  9.   open Access Types Variables Modules ModuleUtil Lambda ErrorMsg
  10.  
  11.   val exnBind = ref bogusEXN
  12.   val exnMatch = ref bogusEXN
  13.   val exnOrd = ref bogusEXN
  14.   val exnRange = ref bogusEXN
  15.   val exnSubscript = ref bogusEXN
  16.   val exnRealSubscript = ref bogusEXN
  17.   val stringequalPath = ref[0]
  18.   val polyequalPath = ref[0]
  19.   val registerPath = ref[0]
  20.   val sregisterPath = ref[0]
  21.   val forcerPath = ref[0]
  22.   val corePath = ref([] : int list)
  23.   val coreLty = ref ((fn _ => impossible "CoreInfo.coreLty1") : int -> lty)
  24.   val vector0Path = ref [0]
  25.   val getDebugVar = ref(mkVALvar (Symbol.varSymbol "getDebug"))
  26.   val errorMatchPath = ref Variables.ERRORvar
  27.  
  28.   fun resetCore () = 
  29.       (exnBind := bogusEXN;
  30.        exnMatch := bogusEXN;
  31.        exnOrd := bogusEXN;
  32.        exnRange := bogusEXN;
  33.        exnSubscript := bogusEXN;
  34.        exnRealSubscript := bogusEXN;
  35.        stringequalPath := [0];
  36.        polyequalPath := [0];
  37.        registerPath := [0];
  38.        sregisterPath := [0];
  39.        forcerPath := [0];
  40.        corePath := [];
  41.        coreLty := ((fn _ => impossible "CoreInfo.coreLty2") : int -> lty);
  42.        vector0Path := [0];
  43.        getDebugVar = ref(mkVALvar (Symbol.varSymbol "getDebug"));
  44.        errorMatchPath := Variables.ERRORvar)
  45.  
  46.   fun setCore(env,spath) =
  47.       let val err = (fn _ => ErrorMsg.impossible)
  48.           val svCore as STRvar{access=Access.PATH[lvCore],binding,...} =
  49.                      lookSTR(env,spath,err)
  50.           val ltyCore = TransBinding.transStrLty binding
  51.           fun extractPath name = 
  52.           let val spath' = spath @ [Symbol.varSymbol name]
  53.           val VARbind(VALvar{access=PATH p,...}) = 
  54.                 lookVARCON (env,spath',err)
  55.            in p end
  56.           fun extractVariable name =
  57.               let val spath' = spath @ [Symbol.varSymbol name]
  58.                   val VARbind var =
  59.                         lookVARCON (env,spath',fn _ => ErrorMsg.impossible)
  60.               in var end
  61.       fun coreExn name = 
  62.           let val spath' = spath @ [Symbol.varSymbol name]
  63.           in lookEXN (env,spath',err)
  64.           end
  65.        in exnBind := coreExn "Bind";
  66.       exnMatch := coreExn "Match";
  67.           exnOrd := coreExn "Ord";
  68.           exnRange := coreExn "Range";
  69.           exnSubscript := coreExn "Subscript";
  70.         exnRealSubscript := coreExn "RealSubscript";
  71.       stringequalPath := extractPath "stringequal";
  72.       forcerPath := extractPath "forcer_p";
  73.       polyequalPath := extractPath "polyequal";
  74.       registerPath := extractPath "profile_register";
  75.       sregisterPath := extractPath "profile_sregister";
  76.           errorMatchPath := extractVariable "errorMatch";
  77.       getDebugVar := let val name = Symbol.varSymbol "getDebug"
  78.                  val VARbind x =
  79.                  lookVARCON (env,spath @ [name],
  80.                          err)
  81.               in x
  82.              end;
  83.           vector0Path := extractPath "vector0";
  84.       corePath := tl(!stringequalPath);
  85.           coreLty := (fn x => (if (x = lvCore) then ltyCore
  86.                                else impossible "CoreInfo.coreLty3"))
  87.       end
  88.  
  89. end (* CoreInfo *)
  90.